home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / defrecord.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  2.0 KB  |  70 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: defrecord.lisp,v 1.2 91/02/08 13:32:02 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; DefRecord -- a thing to take the place of DefAlienStructure.
  15.  
  16. (in-package 'lisp)
  17. (in-package 'system)
  18. (export '(defrecord record-size))
  19. (in-package 'lisp)
  20.  
  21. (defun concat-pnames* (name1 name2)
  22.   (if name1
  23.       (make-symbol (concatenate 'simple-string (symbol-name name1)
  24.                 (symbol-name name2)))
  25.       name2))
  26.  
  27. #-new-compiler
  28. (eval-when (compile)
  29.   (setq lisp::*bootstrap-defmacro* t))
  30.  
  31.  
  32. ;;; We want to be able to do something like this:
  33. ;;;
  34. ;;; (defrecord message
  35. ;;;   (simplep boolean (words 1))
  36. ;;;   (size (signed-byte 32) (long-words 1))
  37. ;;;   (type (signed-byte 32) (long-words 1))
  38. ;;;   (local-port port (long-words 1))
  39. ;;;   (remote-port port (long-words 1))
  40. ;;;   (id (signed-byte 32) (long-words 1)))
  41. ;;;
  42.  
  43. (defmacro defrecord (name &rest slots)
  44.   `(progn
  45.     ,(do ((slots slots (cdr slots))
  46.        (bit-index 0)
  47.        (defops ())
  48.        (prefix (concat-pnames* name '-)))
  49.       ((null slots)
  50.        `(eval-when ,*alien-eval-when*
  51.          ,@(nreverse defops)
  52.          (setf (get ',name 'record-size) ,bit-index)))
  53.     (let* ((slot (car slots))
  54.            (slot-name (car slot))
  55.            (type (cadr slot))
  56.            (size (eval (caddr slot))))
  57.       (push
  58.        `(defoperator (,(concat-pnames prefix slot-name) ,type) ((,name ,name))
  59.           `(alien-index (alien-value ,,name) ,',bit-index ,',size))
  60.        defops)
  61.       (incf bit-index size)))))
  62.  
  63. (defun record-size (name)
  64.   (or (get name 'record-size)
  65.       (error "~S is not a defined record." name)))
  66.  
  67. #-new-compiler
  68. (eval-when (compile)
  69.   (setq lisp::*bootstrap-defmacro* nil))
  70.